{
        MIDICOM - MIDI Commander
    Copyright 2012-2013 J.W. Jagersma

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 }

program MIDICommand;
uses DOS, CRT;

var
   p            : Word;
   Verbose      : Boolean;
   Quiet        : Boolean;

const
     hex        : String = '0123456789ABCDEF';
     ver        : String = '20131101';

function Hex2Dec(s: String): Word;
var
   i: Integer;
   j: Integer;
   a: Word;
begin
     a := 0; j := 0;
     for i := 1 to Length(s) do
     begin
          if (Pos(s[i], hex) = 0) then continue;
          a := (a shl 4) + (Pos(s[i], hex) - 1);
          Inc(j);
     end;
     if (j = 0) then a := $FFFF;
     Hex2Dec := a;
end;

function Dec2Hex(b: Word): String;
var
   s: String;
begin
     s := '';
     while b > 0 do
     begin
          s := hex[(b mod 16) + 1] + s;
          b := b shr 4;
     end;
     while Length(s) < 2 do s := '0' + s;
     Dec2Hex := s;
end;


procedure Send(s: String);
var
   a: Word;
   b: Byte;
   i: Integer;
   j: Integer;

begin
     j := 1; b := 0;
     for i := 1 to Length(s) do
     begin
          a := Hex2Dec(Copy(s, i, 1));
          if (a = $FFFF) then continue;

          b := b + (a shl (4 * j));

          Dec(j);

          if (j = -1) then
          begin
               while (Port[p + 1] and $40) > 0 do Delay(1);
               Port[p] := b;
               if not Quiet then
                  if Verbose then Write(' ' + Dec2Hex(b))
                             else Write('.');
               j := 1;
               b := 0;
          end;
     end;
     if not Quiet then WriteLn;
end;

procedure SendCommand(s: String; name: String);
begin
     if (s = '') then exit;
     if not Quiet then Write('Sending ' + name + '...');
     Send(s);
end;

procedure ParseCommand(s: String);
var
   a, b, c: String;
   i, j: Integer;
   f: Text;
begin
     for i := 1 to Length(s) do
        s[i] := UpCase(s[i]);
     Delete(s, Pos('//', s), 255);
     While Pos(' ', s) > 0 do Delete(s, Pos(' ', s), 1);
     if (s[1] = '/') or (s[1] = '-') or (Length(s) = 0) then exit;

     a := ''; b := '';
     if Pos('=', s) > 0 then
     begin;
        a := Copy(s, Pos('=', s) + 1, 255);
        if Pos('=', a) > 0 then
        begin
           b := Copy(a, Pos('=', a) + 1, 255);
           Delete(a, Pos('=', a), 255);
        end;
        Delete(s, Pos('=', s), 255);
     end;
     while Length(a) < 2 do a := '0' + a;
     while Length(b) < 2 do b := '0' + b;
     
     if (s = 'MPU_RESET') then
     begin
          if not Quiet then Write('Resetting MPU-401...');
          Port[p + 1] := $FF;

          i := 0; j := 0;
          while (i <> $FE) do {Wait for ACK}
          begin
               while (Port[p + 1] and $80) > 0 do {Check DATA SET READY bit}
               begin
                    Delay(10);
                    Write('.');
                    Inc(j);
                    if (j > 10) then
                    begin
                         WriteLn('WARNING: No response from MPU-401 (possibly clone card?)');
                         break;
                    end;
               end;
               if (j > 10) then break;
               i := Port[p];
          end;
          if not Quiet then WriteLn;

          if not Quiet then WriteLn('Enabling UART mode...');
          Port[p + 1] := $3F;
          Delay(100);
     end

     else if (s = 'MODE') then
     begin
          if (a = 'XG') then
          begin
               SendCommand('F0 43 10 4C 00 00 7E 00 F7', 'XG SYSTEM ON');
          end
          else if (a = 'GS') then
          begin
               SendCommand('F0 41 10 42 12 40 00 7F 00 41 F7', 'GS SYSTEM ON');
          end
          else if (a = 'GM') then
          begin
               SendCommand('F0 7E 7F 09 01 F7', 'GM SYSTEM ON');
          end
          else
          begin
               WriteLn('WARNING: Unknown operating mode: ' + a);
          end;
          Delay(500);
     end

     else if (s = 'BANK_MSB') then
     begin
          if Hex2Dec(a) > 15 then
          begin
               SendCommand('B0 00 ' + b +
                           'B1 00 ' + b +
                           'B2 00 ' + b +
                           'B3 00 ' + b +
                           'B4 00 ' + b +
                           'B5 00 ' + b +
                           'B6 00 ' + b +
                           'B7 00 ' + b +
                           'B8 00 ' + b +
                           'B9 00 ' + b +
                           'BA 00 ' + b +
                           'BB 00 ' + b +
                           'BC 00 ' + b +
                           'BD 00 ' + b +
                           'BE 00 ' + b +
                           'BF 00 ' + b ,
                           'C=* BANK_MSB=' + b);
          end
          else
          begin
               Delete(a, 1, 1);
               SendCommand('B' + a + ' 00 ' + b, 'C=' + a + ' BANK_MSB=' + b);
          end
     end

     else if (s = 'BANK_LSB') then
     begin
          if Hex2Dec(a) > 15 then
          begin
               SendCommand('B0 20 ' + b +
                           'B1 20 ' + b +
                           'B2 20 ' + b +
                           'B3 20 ' + b +
                           'B4 20 ' + b +
                           'B5 20 ' + b +
                           'B6 20 ' + b +
                           'B7 20 ' + b +
                           'B8 20 ' + b +
                           'B9 20 ' + b +
                           'BA 20 ' + b +
                           'BB 20 ' + b +
                           'BC 20 ' + b +
                           'BD 20 ' + b +
                           'BE 20 ' + b +
                           'BF 20 ' + b ,
                           'C=* BANK_LSB=' + b);
          end
          else
          begin
               Delete(a, 1, 1);
               SendCommand('B' + a + ' 20 ' + b, 'C=' + a + ' BANK_LSB=' + b);
          end
     end

     else if (s = 'DELAY') then
     begin
          Delay(Hex2Dec(a));
     end
{}
     else if (s = 'XG_RESET') then
     begin
          SendCommand('F0 43 10 4C 00 00 7F 00 F7', 'PARAMETER RESET');
     end

     else if (s = 'XG_MASTERVOL') then
     begin
          SendCommand('F0 7F 7F 04 01 00 '+a+' F7', 'MASTER VOLUME=' + a);
     end

     else if (s = 'AD_INPUT') then
     begin
          SendCommand('F0 43 10 49 01 00 00 '+a+' F7', 'A/D ENABLE=' + a);
     end

     else if (s = 'AD_MODE') then
     begin
          if      (a = '00') then
          begin
               SendCommand('F0 43 10 4C 11 00 00 00 F7', 'A/D MODE=MONO');
          end
          else if (a = '01') then
          begin
               SendCommand('F0 43 10 4C 11 00 00 01 F7', 'A/D MODE=STEREO');
          end
          else
          begin
              WriteLn('WARNING: Unknown AD mode: ' + a);
          end;
     end

     else if (s = 'AD_VOLUME') then
     begin
          SendCommand('F0 43 10 4C 10 00 0B '+a+' F7', 'A/D PART 1 VOLUME=' + a);
          SendCommand('F0 43 10 4C 10 01 0B '+a+' F7', 'A/D PART 2 VOLUME=' + a);
     end

     else if (s = 'AD_DRY') then
     begin
          SendCommand('F0 43 10 4C 10 00 11 '+a+' F7', 'A/D PART 1 DRY=' + a);
          SendCommand('F0 43 10 4C 10 01 11 '+a+' F7', 'A/D PART 2 DRY=' + a);
     end

     else if (s = 'AD_CHORUS') then
     begin
          SendCommand('F0 43 10 4C 10 00 12 '+a+' F7', 'A/D PART 1 CHORUS=' + a);
          SendCommand('F0 43 10 4C 10 01 12 '+a+' F7', 'A/D PART 2 CHORUS=' + a);
     end

     else if (s = 'AD_REVERB') then
     begin
          SendCommand('F0 43 10 4C 10 00 13 '+a+' F7', 'A/D PART 1 REVERB=' + a);
          SendCommand('F0 43 10 4C 10 01 13 '+a+' F7', 'A/D PART 2 REVERB=' + a);
     end

     else if (s = 'AD_VARIATION') then
     begin
          SendCommand('F0 43 10 4C 10 00 14 '+a+' F7', 'A/D PART 1 VARIATION=' + a);
          SendCommand('F0 43 10 4C 10 01 14 '+a+' F7', 'A/D PART 2 VARIATION=' + a);
     end

     else if (s = 'R_TYPE') then
     begin
          if      (a = 'OFF') then
               SendCommand('F0 43 10 4C 02 01 00 00 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'HALL1') then
               SendCommand('F0 43 10 4C 02 01 00 01 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'HALL2') then
               SendCommand('F0 43 10 4C 02 01 00 01 01 F7', 'REVERB TYPE=' + a)
          else if (a = 'ROOM1') then
               SendCommand('F0 43 10 4C 02 01 00 02 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'ROOM2') then
               SendCommand('F0 43 10 4C 02 01 00 02 01 F7', 'REVERB TYPE=' + a)
          else if (a = 'ROOM3') then
               SendCommand('F0 43 10 4C 02 01 00 02 02 F7', 'REVERB TYPE=' + a)
          else if (a = 'STAGE1') then
               SendCommand('F0 43 10 4C 02 01 00 03 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'STAGE2') then
               SendCommand('F0 43 10 4C 02 01 00 03 01 F7', 'REVERB TYPE=' + a)
          else if (a = 'PLATE') then
               SendCommand('F0 43 10 4C 02 01 00 04 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'WHITEROOM') then
               SendCommand('F0 43 10 4C 02 01 00 10 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'TUNNEL') then
               SendCommand('F0 43 10 4C 02 01 00 11 00 F7', 'REVERB TYPE=' + a)
          else if (a = 'BASEMENT') then
               SendCommand('F0 43 10 4C 02 01 00 13 00 F7', 'REVERB TYPE=' + a)
          else
               WriteLn('WARNING: Unknown reverb type: ' + a);
     end


     else if (s = 'R_TIME') then
     begin
          SendCommand('F0 43 10 4C 02 01 02 '+a+' F7', 'REVERB TIME=' + a);
     end


     else if (s = 'R_DIFFUSION') then
     begin
          SendCommand('F0 43 10 4C 02 01 03 '+a+' F7', 'REVERB DIFFUSION=' + a);
     end


     else if (s = 'R_INITDELAY') then
     begin
          SendCommand('F0 43 10 4C 02 01 04 '+a+' F7', 'REVERB INITIAL DELAY=' + a);
     end


     else if (s = 'R_HPF_CUTOFF') then
     begin
          SendCommand('F0 43 10 4C 02 01 05 '+a+' F7', 'REVERB HIGH FILTER CUTOFF=' + a);
     end


     else if (s = 'R_LPF_CUTOFF') then
     begin
          SendCommand('F0 43 10 4C 02 01 06 '+a+' F7', 'REVERB LOW FILTER CUTOFF=' + a);
     end


     else if (s = 'R_DRYWET') then
     begin
          SendCommand('F0 43 10 4C 02 01 0B '+a+' F7', 'REVERB DRY/WET BALANCE=' + a);
     end


     else if (s = 'R_RETURN') then
     begin
          SendCommand('F0 43 10 4C 02 01 0C '+a+' F7', 'REVERB RETURN LEVEL=' + a);
     end


     else if (s = 'R_PAN') then
     begin
          SendCommand('F0 43 10 4C 02 01 0D '+a+' F7', 'REVERB PAN=' + a);
     end


     else if (s = 'R_DELAY') then
     begin
          SendCommand('F0 43 10 4C 02 01 10 '+a+' F7', 'REVERB DELAY=' + a);
     end

     else if (s = 'R_DENSITY') then
     begin
          SendCommand('F0 43 10 4C 02 01 11 '+a+' F7', 'REVERB DENSITY=' + a);
     end

     else if (s = 'R_REFLECTION') then
     begin
          SendCommand('F0 43 10 4C 02 01 12 '+a+' F7', 'REVERB REFLECTION=' + a);
     end

     else if (s = 'R_FEEDBACK') then
     begin
          SendCommand('F0 43 10 4C 02 01 14 '+a+' F7', 'REVERB FEEDBACK=' + a);
     end

     else if (s = 'R_WIDTH') then
     begin
          SendCommand('F0 43 10 4C 02 01 07 '+a+' F7', 'REVERB ROOM WIDTH=' + a);
     end

     else if (s = 'R_HEIGHT') then
     begin
          SendCommand('F0 43 10 4C 02 01 08 '+a+' F7', 'REVERB WOOM WIDTH=' + a);
     end

     else if (s = 'R_DEPTH') then
     begin
          SendCommand('F0 43 10 4C 02 01 09 '+a+' F7', 'REVERB ROOM DEPTH=' + a);
     end

     else if (s = 'R_WALL') then
     begin
          SendCommand('F0 43 10 4C 02 01 0A '+a+' F7', 'REVERB WALL VARIATION=' + a);
     end

     else if (s = 'C_TYPE') then
     begin
          if      (a = 'OFF') then
               SendCommand('F0 43 10 4C 02 01 20 00 00 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CHORUS1') then
               SendCommand('F0 43 10 4C 02 01 20 41 00 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CHORUS2') then
               SendCommand('F0 43 10 4C 02 01 20 41 01 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CHORUS3') then
               SendCommand('F0 43 10 4C 02 01 20 41 02 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CHORUS4') then
               SendCommand('F0 43 10 4C 02 01 20 41 08 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CELESTE1') then
               SendCommand('F0 43 10 4C 02 01 20 42 00 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CELESTE2') then
               SendCommand('F0 43 10 4C 02 01 20 42 01 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CELESTE3') then
               SendCommand('F0 43 10 4C 02 01 20 42 02 F7', 'CHORUS TYPE=' + a)
          else if (a = 'CELESTE4') then
               SendCommand('F0 43 10 4C 02 01 20 42 08 F7', 'CHORUS TYPE=' + a)
          else if (a = 'FLANGER1') then
               SendCommand('F0 43 10 4C 02 01 20 43 00 F7', 'CHORUS TYPE=' + a)
          else if (a = 'FLANGER2') then
               SendCommand('F0 43 10 4C 02 01 20 43 01 F7', 'CHORUS TYPE=' + a)
          else if (a = 'FLANGER3') then
               SendCommand('F0 43 10 4C 02 01 20 43 08 F7', 'CHORUS TYPE=' + a)
          else
               WriteLn('WARNING: Unknown chorus type: ' + a);
     end

     else if (s = 'C_LFOFREQ') then
     begin
          SendCommand('F0 43 10 4C 02 01 22 '+a+' F7', 'CHORUS LFO FREQ=' + a);
     end

     else if (s = 'C_LFODEPTH') then
     begin
          SendCommand('F0 43 10 4C 02 01 23 '+a+' F7', 'CHORUS LFO DEPTH=' + a);
     end

     else if (s = 'C_FEEDBACK') then
     begin
          SendCommand('F0 43 10 4C 02 01 24 '+a+' F7', 'CHORUS FEEDBACK=' + a);
     end

     else if (s = 'C_DELAY') then
     begin
          SendCommand('F0 43 10 4C 02 01 25 '+a+' F7', 'CHORUS DELAY=' + a);
     end

     else if (s = 'C_EQLOWFREQ') then
     begin
          SendCommand('F0 43 10 4C 02 01 27 '+a+' F7', 'CHORUS EQ LOW FREQ=' + a);
     end

     else if (s = 'C_EQLOWGAIN') then
     begin
          SendCommand('F0 43 10 4C 02 01 28 '+a+' F7', 'CHORUS EQ LOW GAIN=' + a);
     end

     else if (s = 'C_EQHIGHFREQ') then
     begin
          SendCommand('F0 43 10 4C 02 01 29 '+a+' F7', 'CHORUS EQ HIGH FREQ=' + a);
     end

     else if (s = 'C_EQHIGHGAIN') then
     begin
          SendCommand('F0 43 10 4C 02 01 2A '+a+' F7', 'CHORUS EQ HIGH GAIN=' + a);
     end

     else if (s = 'C_DRYWET') then
     begin
          SendCommand('F0 43 10 4C 02 01 2B '+a+' F7', 'CHORUS DRY/WET BALANCE=' + a);
     end

     else if (s = 'C_RETURN') then
     begin
          SendCommand('F0 43 10 4C 02 01 2C '+a+' F7', 'CHORUS RETURN LEVEL=' + a);
     end

     else if (s = 'C_PAN') then
     begin
          SendCommand('F0 43 10 4C 02 01 2D '+a+' F7', 'CHORUS PAN=' + a);
     end

     else if (s = 'C_TOREVERB') then
     begin
          SendCommand('F0 43 10 4C 02 01 2E '+a+' F7', 'CHORUS TO REVERB=' + a);
     end

     else if (s = 'C_INPUTMODE') then
     begin
          SendCommand('F0 43 10 4C 02 01 34 '+a+' F7', 'CHORUS INPUT MODE=' + a);
     end

     else if (s = 'C_LFOPHASE') then
     begin
          SendCommand('F0 43 10 4C 02 01 33 '+a+' F7', 'FLANGER LFO PHASE=' + a);
     end

     {
     else if (s = '') then
     begin
          SendCommand('', '');
     end
     }

     else if (FSearch(s, '') <> '') or (FSearch(s + '.CFG', '') <> '') then
     begin
          if (FSearch(s + '.CFG', '') <> '') then s := s + '.CFG';

          if Quiet then WriteLn;
          Write('Reading file ' + s + '.');
          if not Quiet then WriteLn;

          Assign(f, s);
          Reset(f);

          while not EOF(f) do
          begin
               ReadLn(f, s);
               ParseCommand(s);
          end;
          Close(f);
     end

     else
         SendCommand(s, s);

     if Quiet then Write('.');
end;

procedure ShowUsage;
var
   f: String;
begin
     f := ParamStr(0);
     while (Pos('\', f) > 0) do Delete(f, 1, Pos('\', f));
     Delete(f, Pos('.', f), 4);

     WriteLn;
     WriteLn('Sends MIDI data through the MPU-401 port. Includes special commands');
     WriteLn('for the Yamaha DB60XG / NEC XR385 wavetable synthesizer cards.');
     WriteLn;
     WriteLn('-     Usage:');
     WriteLn(     f + ' [/P=xxx] [/S] [file] [command] [midi data] [...]');
     WriteLn;
     WriteLn('- Arguments:');
     WriteLn('    /P=xxx : Set MPU port, where xxx is the port address in hex.');
     WriteLn('             If /P is not set, uses environment variable MPU=xxx');
     WriteLn('             or BLASTER=Pxxx. If these variable are not present,');
     WriteLn('             port is assumed to be 330h.');
     WriteLn('        /V : Verbose mode: show raw MIDI data.');
     WriteLn('        /Q : Quiet mode: do not show every command being sent.');
     WriteLn('      file : Script file containing commands, midi data, or other');
     WriteLn('             file names. If extension is not given, .CFG is used.');
     WriteLn('   command : DB60XG command, see sample configuration files for');
     WriteLn('             a list of available commands.');
     WriteLn(' midi data : Raw midi data. If the argument is neither a file nor');
     WriteLn('             a command, it is sent as midi data. Any non-hex');
     WriteLn('             characters are ignored.');
     WriteLn('             For example: "' + f + ' F0 7E 7F 09 01 F7"');
     WriteLn('             will send a "General Midi On" SysEx message.');
     Halt;
end;

var
   s: String;
   i, j: Integer;
begin
     p := Hex2Dec(GetEnv('MPU'));
     if (p = $FFFF) or (p = 0) then
     begin
          s := GetEnv('BLASTER');
          Delete(s, 1, Pos('P', s));
          Delete(s, Pos(' ', s), 255);
          p := Hex2Dec(s);
     end;
     if (p = $FFFF) or (p = 0) then p := $330;
     Verbose := false;

     WriteLn('--- MIDI Commander ---');
     WriteLn('-- by J.W. Jagersma --');
     WriteLn('-  version '+ver+ '  -');

     if (ParamCount = 0) then ShowUsage;

     for i := 1 to ParamCount do
     begin
         s := ParamStr(i);
         for j := 1 to Length(s) do
             s[j] := UpCase(s[j]);
         if (s[1] = '/') or (s[1] = '-') then
         begin
              if (s[2] = 'V') then
              begin
                   Verbose := true;
              end
              else if (s[2] = 'Q') then
              begin
                   Quiet := true;
              end
              else if (s[2] = 'P') then
              begin
                   s := Copy(s, Pos('=', s) + 1, 255);
                   p := Hex2Dec(s);
              end
              else
                  ShowUsage;
         end;
     end;
     if not Quiet then WriteLn('Using port 0x' + Dec2Hex(p) + '.');

     if (Port[p + 1] and $40) > 0 then {Check DATA READ READY bit}
     begin
          WriteLn('ERROR: MPU-401 not ready!');
          Halt;
     end;
     if not Quiet then WriteLn('MPU-401 ready.');

     for i := 1 to ParamCount do
          ParseCommand(ParamStr(i));

     WriteLn;
end.